home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Just Call Me Internet
/
Just Call Me Internet.iso
/
prog
/
atari
/
m2
/
cat3src
/
cat
/
storage.i
< prev
next >
Wrap
Text File
|
1997-10-26
|
41KB
|
1,390 lines
IMPLEMENTATION MODULE Storage;
(*$Y+,R-,Z-*)
(*-----------------------------------------------------------------------------
* Copyright Januar 1989 Thomas Tempelmann
*-----------------------------------------------------------------------------
* Kurzbeschreibung : Auf StorBase aufgesetzte, systemunabhngige Memory-
* verwaltung fr MOS
*-----------------------------------------------------------------------------
* Systemversion : MOS 1.1
* Textversion : V#0293
*-----------------------------------------------------------------------------
* Datum Vers Autor Bemerkung (Arbeitsbericht)
*-----------------------------------------------------------------------------
* 14.02.92 2.15 TT 'valid' benutzt Super() statt Supexec() wg. MiNT.
* 10.11.90 2.14 TT ALLOCATE/SysAlloc erkennt 0-size sofort
* 08.11.90 TT $R-
* 26.10.90 2.13 TT Neg. berlufe bei size-Parm bei ALLOCATE/Enlarge weg.
* 11.10.90 2.12 TT StorBase.Resize-Aufruf gab zu viel frei.
* 09.10.90 2.11 TT DEALLOCATE gibt nix frei, wenn kein FullAcess und
* size # 0; DEALLOCATE ruft ggf. Resize statt DEALLOCATE
* in StorBase, damit shrink immer mglich ist.
* 26.09.90 2.10 TT MaxBlSize wird bei ACCs auf 2KB gesetzt, weil sonst
* gleich meist 32K drauf gehen.
* 19.08.90 2.9 TT MemAvail macht keinen Overflow, wenn weniger als 40
* Byte frei sind.
* 29.07.90 2.8 TT Available gendert.
* 23.07.90 2.7 TT ALLOCATE kann nun auch Speicher < MaxBlSize noch
* anfordern, solange StorBase noch davon was brig hat.
* 15.07.90 2.6 TT Kritische StorBase-Routinen werden nur bei
* 'FullStorBaseAccess' aufgerufen.
* 13.06.90 TT EnterSupervisorMode raus
* 14.03.90 2.5 TT ALOCATE/SysAlloc mit size=0 liefern NIL als Ptr.
* (bisher wurde trotzdem ein Header alloziert);
* MemAvail: BlockFullSize wird zustzlich vom freien
* Bereich abgezogen
* 11.01.90 2.4 TT Verify-Routine in Asm kodiert, prft nun auch
* Pointer auf Gltigkeit, soda kein Adr/Bus-Error
* kommen kann; auerdem wird bei Erkennen eines
* Fehlers die Speicherkette mit den noch intakten
* Daten geschlossen
* 07.07.89 2.3 TT Optimierung einige Routinen in Asm
* 05.06.89 2.3 TT Nach Freigabe residenter Module wird nun nicht mehr
* Speicherverw. inkonsistent. Grund: 'valid' erkennt nun,
* wenn schon freigegebener Bereich nochmal freigegeben
* wird.
* 02.06.89 2.3 TT More liefert ADR (Root) PROC (Resize) und PROC (Verify)
* 14.05.89 2.2 TT Es steckt noch ein Fehler entw. in MemSize oder
* DEALLOCATE mit size>0!
* Zur Sicherheit bei blockOK.ubNeg ANDI.L eingefgt
* (wei aber nicht, ob dies redundant ist).
* 04.03.89 2.1 TT getFree: full nicht erkannt, wenn origLen knapp unter
* MaxBlSize lag. newBlock legte aber dann ggf. zuwenig
* Speicher an.
* 18.02.89 2.0 TT 1. Freigabe zum Testen (an Manuel, MAUS)
*----------------------------------------------------------------------------*)
FROM SYSTEM IMPORT ASSEMBLER, WORD, LONGWORD, ADR, TSIZE, BYTE, ADDRESS;
FROM MOSGlobals IMPORT MemArea, InternalFault;
FROM MOSConfig IMPORT MaxBlSize;
FROM MOSSupport IMPORT ToSuper, ToUser;
FROM PrgCtrl IMPORT Accessory, EnvlpCarrier, TermCarrier, CatchProcessTerm,
SetEnvelope;
IMPORT StorBase;
TYPE
PtrHead = POINTER TO Head;
HeadLink = RECORD
n: INTEGER; (* rel. offset von block.data *)
p: INTEGER; (* rel. offset von block.data *)
END;
Head = RECORD; (* werden nur fr used-Bereiche benutzt *)
hd: HeadLink;
root: INTEGER; (* rel. Offset von Block.data (pos.Wert) *)
level: INTEGER;
size: INTEGER; (* used-Gre, kann ungerade sein! *)
(* -- mu immer vor 'hd.data' stehen *)
(* damit 'fullBlk' funktioniert! *)
data: BYTE (* Beginn der Daten *)
END;
CONST
HeadSize = 10; (* TSIZE (Head ohne data) *)
TYPE
PtrLink = POINTER TO Link;
Link = RECORD
next: PtrLink;
prev: PtrLink;
END;
PtrBlock = POINTER TO Block;
Block = RECORD
blk: Link;
size: LONGINT; (* Gre des verfgbaren Bereichs *)
(* kann ungerade sein! *)
(* Bit 30: <full> *)
CASE : CARDINAL OF
| 0: (* full *)
level: INTEGER;
full: CARDINAL; (* = 0, wenn full *)
fullData: BYTE
| 1: (* root *)
blRov: PtrBlock (* zeigt direkt auf letzten Block *)
| 2: (* not full *)
hd: HeadLink;
hdRov: INTEGER; (* letzer hd, wo alloc durchgef. wurde *)
free: LONGINT; (* gesamter freier Bereich in Block *)
hds : BYTE (* Beginn der Header/Freibereiche *)
END
END;
CONST
BlockSize = 22; (* TSIZE (Block ohne hds) *)
BlockFullSize = 16; (* TSIZE (Block, 0) *)
VAR Root: Block;
StorLevel: INTEGER; (* 0: Sys *)
_membot, _memtop: ADDRESS;
PROCEDURE abs (bl: PtrBlock; hd: INTEGER): ADDRESS;
(*$L-*)
BEGIN
ASSEMBLER
; RETURN ADR (bl^.hds) + LONGCARD (LONG (hd))
MOVE -(A3),D0
MOVE.L -(A3),A0
; ADDA.W D0,A0
; ADDA.W #BlockSize,A0
LEA BlockSize(A0,D0.W),A0
MOVE.L A0,(A3)+
END
END abs;
(*$L=*)
PROCEDURE rel (bl: PtrBlock; ad: ADDRESS): INTEGER;
(*$L-*)
BEGIN
ASSEMBLER
; RETURN SHORT ( ad - ADR (bl^.hds) )
MOVE.L -(A3),D0
MOVE.L -(A3),A0
ADDA.W #BlockSize,A0
SUB.L A0,D0
MOVE.W D0,(A3)+
END
END rel;
(*$L=*)
MODULE BlkLists;
IMPORT ASSEMBLER, abs, rel, ADR, Link, PtrBlock, HeadLink, BlockSize;
EXPORT linkBlkIn, linkBlkOut,
linkHdIn, linkHdOut;
(*
PROCEDURE linkBlkIn (VAR l, at: Link);
BEGIN
l.prev:= at.prev;
l.next:= ADR (at);
at.prev^.next:= ADR (l);
at.prev:= ADR (l)
END linkBlkIn;
PROCEDURE linkBlkOut (VAR l: Link);
BEGIN
l.prev^.next:= l.next;
l.next^.prev:= l.prev
END linkBlkOut;
PROCEDURE linkHdIn (bl: PtrBlock; VAR l: HeadLink; before: INTEGER);
VAR at, at2: POINTER TO HeadLink;
BEGIN
at:= abs (bl, before);
l.p:= at^.p;
l.n:= before;
at2:= abs (bl, at^.p);
at2^.n:= rel (bl, ADR (l));
at^.p:= rel (bl, ADR (l))
END linkHdIn;
PROCEDURE linkHdOut (bl: PtrBlock; VAR l: HeadLink);
VAR at: POINTER TO HeadLink;
BEGIN
at:= abs (bl, l.p);
at^.n:= l.n;
at:= abs (bl, l.n);
at^.p:= l.p
END linkHdOut;
*)
(*$L-*)
PROCEDURE linkBlkIn (VAR l, at: Link);
BEGIN
ASSEMBLER
; l.prev:= at.prev;
; l.next:= ADR (at);
; at.prev^.next:= ADR (l);
; at.prev:= ADR (l)
MOVE.L -(A3),A1 ; ADR (at)
MOVE.L -(A3),A0 ; ADR (l)
MOVE.L Link.prev(A1),A2
MOVE.L A2,Link.prev(A0)
MOVE.L A1,Link.next(A0)
MOVE.L A0,Link.next(A2)
MOVE.L A0,Link.prev(A1)
END
END linkBlkIn;
PROCEDURE linkBlkOut (VAR l: Link);
BEGIN
ASSEMBLER
; l.prev^.next:= l.next;
; l.next^.prev:= l.prev
MOVE.L -(A3),A0 ; ADR (l)
MOVE.L Link.prev(A0),A1
MOVE.L Link.next(A0),A2
MOVE.L A2,Link.next(A1)
MOVE.L A1,Link.prev(A2)
END
END linkBlkOut;
PROCEDURE linkHdIn (bl: PtrBlock; VAR l: HeadLink; before: INTEGER);
VAR at, at2: POINTER TO HeadLink;
BEGIN
ASSEMBLER
MOVE -(A3),D0 ; before
MOVE.L -(A3),A0 ; ADR (l)
MOVE.L -(A3),A1 ; bl
; at:= abs (bl, before);
; MOVE.L A1,A2
; ADDA.W D0,A2
; ADDA.W #BlockSize,A2 ; at
LEA BlockSize(A1,D0.W),A2
; l.p:= at^.p;
MOVE.W HeadLink.p(A2),D1 ; at^.p
MOVE.W D1,HeadLink.p(A0)
; l.n:= before;
MOVE.W D0,HeadLink.n(A0)
; BERECHNE rel (bl, ADR (l)) NACH A0
ADDA.W #BlockSize,A1
SUBA.L A1,A0
; at2:= abs (bl, at^.p);
ADDA.W D1,A1 ; at2
; at2^.n:= rel (bl, ADR (l));
; at^.p:= rel (bl, ADR (l))
MOVE.W A0,HeadLink.n(A1)
MOVE.W A0,HeadLink.p(A2)
END
END linkHdIn;
PROCEDURE linkHdOut (bl: PtrBlock; VAR l: HeadLink);
VAR at: POINTER TO HeadLink;
BEGIN
ASSEMBLER
MOVE.L -(A3),A0 ; ADR (l)
MOVE.L -(A3),A1 ; bl
; at:= abs (bl, l.p);
MOVE.L A1,A2
ADDA.W HeadLink.p(A0),A2
ADDA.W #BlockSize,A2 ; at
; at^.n:= l.n;
MOVE.W HeadLink.n(A0),HeadLink.n(A2)
; at:= abs (bl, l.n);
ADDA.W HeadLink.n(A0),A1
ADDA.W #BlockSize,A1 ; at
; at^.p:= l.p
MOVE.W HeadLink.p(A0),HeadLink.p(A1)
END
END linkHdOut;
(*$L=*)
END BlkLists;
PROCEDURE setBit6 (VAR i: ARRAY OF BYTE);
(*$L-*)
BEGIN
ASSEMBLER
SUBQ.L #2,A3
MOVEA.L -(A3),A0
BSET.B #6,(A0)
END
END setBit6;
(*$L=*)
PROCEDURE blkFull (bl: PtrBlock): BOOLEAN;
(*$L-*)
BEGIN
ASSEMBLER
MOVE.L -(A3),A0
BTST #6,Block.size(A0)
SNE D0
ANDI #1,D0
MOVE D0,(A3)+
END
END blkFull;
(*$L=*)
PROCEDURE blkSize (bl: PtrBlock): LONGINT;
(*$L-*)
BEGIN
ASSEMBLER
MOVE.L -(A3),A0
MOVE.L Block.size(A0),D0
ANDI.L #$00FFFFFF,D0
MOVE.L D0,(A3)+
END
END blkSize;
(*$L=*)
PROCEDURE sizeHd (bl: PtrBlock; hd: INTEGER): INTEGER;
(*$L-*)
BEGIN
ASSEMBLER
; hdp:= abs (bl, hd);
; RETURN val (hdp^.size)
MOVE -(A3),D0
MOVE.L -(A3),A0
MOVE.W Head.size+BlockSize(A0,D0.W),D0
ADDQ #1,D0
ANDI #$FFFE,D0
MOVE D0,(A3)+
END;
END sizeHd;
(*$L=*)
PROCEDURE nextHd (bl: PtrBlock; hd: INTEGER): INTEGER;
(*$L-*)
BEGIN
ASSEMBLER
; hdp:= abs (bl, hd);
; RETURN hdp^.hd.n
MOVE -(A3),D0
MOVE.L -(A3),A0
MOVE.W Head.hd.n+BlockSize(A0,D0.W),(A3)+
END;
END nextHd;
(*$L=*)
PROCEDURE prevHd (bl: PtrBlock; hd: INTEGER): INTEGER;
(*$L-*)
BEGIN
ASSEMBLER
; hdp:= abs (bl, hd);
; RETURN hdp^.hd.p
MOVE -(A3),D0
MOVE.L -(A3),A0
MOVE.W Head.hd.p+BlockSize(A0,D0.W),(A3)+
END;
END prevHd;
(*$L=*)
PROCEDURE valid (ad: ADDRESS; VAR bl: PtrBlock;
VAR hd: PtrHead; VAR full: BOOLEAN): BOOLEAN;
(* Verkettung prfen und ggf. 'bl' und 'full' setzen *)
(*$L-*)
BEGIN
(*
IF ad = NIL THEN RETURN FALSE END;
full:= fullBlk (ad);
IF full THEN
bl:= ad - LONG (BlockFullSize);
ELSE
hd:= ad - LONG (HeadSize);
bl:= ADDRESS (hd) - LONGCARD (LONG (hd^.root + BlockSize));
IF nextHd (bl, hd.p)) # prevHd (bl, hd.n)) # hd THEN
RETURN FALSE
END
END;
RETURN bl^.blk.next^.prev = bl^.blk.prev^.next
*)
ASSEMBLER
(*
SUBQ.L #4,A7
JSR ToSuper
MOVE.L 8,-(A7) ; bus error vector
MOVE.L 12,-(A7) ; address error vector
LEA inval(PC),A0
MOVE.L A0,8
MOVE.L A0,12
MOVE.L A7,D1
*)
MOVE.L -(A3),A2 ; full
MOVE.L -(A3),D2 ; hd
MOVE.L -(A3),A1 ; bl
MOVE.L -(A3),A0 ; ad
MOVE.L A0,D0
BEQ inval
TST.W -2(A0) ; bei <full> ist 'hd.size' = 0
SEQ D0
ANDI #1,D0
MOVE D0,(A2) ; full setzen
BEQ notfull
; bl:= ad - LONG (BlockFullSize)
MOVE.L A0,A2
SUBA.W #BlockFullSize,A2
MOVE.L A2,(A1)
BRA fullend
notfull
; hd:= ad - LONG (HeadSize);
MOVE.L A0,A2
SUBA.W #HeadSize,A2
MOVE.L D2,A0
MOVE.L A2,(A0)
; bl:= ADDRESS (hd) - LONGCARD (LONG (hd^.root + BlockSize));
MOVE.L A2,A0 ; hd retten
SUBA.W Head.root(A2),A2
SUBA.W #BlockSize,A2
MOVE.L A2,(A1)
; rel (bl, hd):
MOVE.L A0,D2 ; hd
MOVE.L A2,A1 ; bl
ADDA.W #BlockSize,A1
SUB.L A1,D2
; IF nextHd (bl, hd.p)) # prevHd (bl, hd.n)) # rel (bl, hd) THEN
MOVE.W Head.hd.p(A0),D0
CMP.W Head.hd.n+BlockSize(A2,D0.W),D2
BNE inval
MOVE.W Head.hd.n(A0),D0
CMP.W Head.hd.p+BlockSize(A2,D0.W),D2
BNE inval
fullend
; RETURN bl^.blk.next^.prev = bl^.blk.prev^.next
MOVE.L Block.blk.next(A2),A1
MOVE.L Block.blk.prev(A1),D0
MOVE.L Block.blk.prev(A2),A1
CMP.L Block.blk.next(A1),D0
SEQ D0
ANDI #1,D0
MOVE D0,(A3)+
BRA ende
inval:
CLR (A3)+
(* MOVE.L D1,A7 *)
ende:
(* MOVE.L (A7)+,12
MOVE.L (A7)+,8
JSR ToUser
ADDQ.L #4,A7
*) END
END valid;
(*$L=*)
PROCEDURE incHdSize (hd: PtrHead; siz: CARDINAL);
(*$L-*)
BEGIN
ASSEMBLER
MOVE.W -(A3),D0
MOVE.L -(A3),A0
ADD.W D0,Head.size(A0)
END
END incHdSize;
(*$L=*)
PROCEDURE decHdSize (hd: PtrHead; siz: CARDINAL);
(*$L-*)
BEGIN
ASSEMBLER
MOVE.W -(A3),D0
MOVE.L -(A3),A0
SUB.W D0,Head.size(A0)
END
END decHdSize;
(*$L=*)
PROCEDURE resize (VAR ad: ADDRESS; len: LONGINT): BOOLEAN;
(*
* 'len': wenn pos, dann Abzugswert; wenn neg., dann Vergrerungsoffset;
* wenn Null, dann ganz freigeben.
* 'ad' bleibt unverndert, wenn RETURN FALSE
*)
VAR hd: PtrHead; bl: PtrBlock; ok, full: BOOLEAN;
i: CARDINAL;
PROCEDURE blkAway;
BEGIN
IF Root.blRov = bl THEN Root.blRov:= NIL END;
linkBlkOut (bl^.blk);
StorBase.DEALLOCATE (bl, 0)
END blkAway;
VAR this, freeEnd, freeBeg: INTEGER;
dumusedbeg, duml, dumfreebeg: INTEGER;
BEGIN (* resize *)
IF NOT valid (ad,bl,hd,full) THEN
RETURN FALSE
END;
IF full THEN
(* <full> block: ad zeigt hinter Block(0) *)
IF len < 0L THEN
(* Block um 'len' vergrern *)
IF StorBase.FullStorBaseAccess () THEN
StorBase.Enlarge (bl, -len, ok);
IF ok THEN bl^.size:= bl^.size + ABS (len) END;
RETURN ok
ELSE
RETURN FALSE
END
ELSIF (len > 0L) AND (len < blkSize (bl)) THEN
(* shrink only *)
bl^.size:= bl^.size - len;
(* Blockgre neu setzen. Plus den Block-Header und aufrunden: *)
StorBase.Resize (bl, (BlockFullSize + blkSize (bl) + 1) DIV 2 * 2, ok);
RETURN ok
ELSE
blkAway;
ad:= NIL
END
ELSE (* NOT full: *)
(* ad zeigt hinter Header *)
IF len < 0L THEN
(* Block um 'len' vergrern *)
this:= rel (bl, hd);
freeEnd:= nextHd (bl, this);
IF freeEnd < 0 THEN freeEnd:= SHORT (blkSize (bl)) END;
freeBeg:= this + HeadSize + sizeHd (bl, this);
IF ABS (len) <= LONG (freeEnd - freeBeg) THEN
i:= SHORT (ABS (len));
incHdSize (hd, i);
DEC (bl^.free, (ORD (ODD (hd^.size)) + i) DIV 2 * 2)
ELSE
RETURN FALSE
END
ELSIF (len > 0L) AND (len < LONG (hd^.size)) THEN
(* shrink only *)
i:= SHORT (len);
decHdSize (hd, i);
INC (bl^.free, (ORD (NOT ODD (hd^.size)) + i) DIV 2 * 2)
ELSE
i:= hd^.size + HeadSize;
IF ODD (i) THEN INC (i) END;
INC (bl^.free, i);
IF bl^.hdRov = rel (bl, hd) THEN
bl^.hdRov:= prevHd (bl, bl^.hdRov)
END;
linkHdOut (bl, hd^.hd);
IF bl^.free = blkSize (bl) THEN blkAway END;
(*
IF hd^.size = 966 THEN
WriteLn;
WriteString ('bl^.size: '); WriteString (CardToStr (bl^.size,0)); WriteLn;
WriteString ('bl^.free: '); WriteString (CardToStr (bl^.free,0)); WriteLn;
dumfreebeg:= 0; (* End of last used area *)
dumusedbeg:= bl^.hd.n; (* Start of new used area *)
LOOP
IF dumusedbeg < 0 THEN
duml:= VAL (INTEGER, blkSize (bl)) - dumfreebeg;
IF duml > 0 THEN WriteString ('free: '); WriteString (IntToStr (duml,8)); WriteString (IntToStr (nextHd(bl,dumusedbeg),8)); WriteString (IntToStr (prevHd(bl,dumusedbeg),8)); WriteLn; END;
EXIT
ELSE
duml:= dumusedbeg - dumfreebeg;
IF duml > 0 THEN WriteString ('free: '); WriteString (IntToStr (duml,8)); WriteString (IntToStr (nextHd(bl,dumusedbeg),8)); WriteString (IntToStr (prevHd(bl,dumusedbeg),8)); WriteLn END;
END;
WriteString ('used: ');
WriteString (IntToStr (sizeHd (bl, dumusedbeg),8));
WriteString (IntToStr (nextHd(bl,dumusedbeg),8));
WriteString (IntToStr (prevHd(bl,dumusedbeg),8));
WriteLn;
dumfreebeg:= dumusedbeg + HeadSize + sizeHd (bl, dumusedbeg);
dumusedbeg:= nextHd (bl, dumusedbeg)
END;
END;
*)
ad:= NIL
END;
END;
RETURN TRUE
END resize;
PROCEDURE blockOK (VAR freeBeg, usedBeg: INTEGER;
neededLen: LONGINT; bl: PtrBlock): BOOLEAN;
(*$L-*)
(* freien Bereich im Block 'bl' suchen *)
VAR end: INTEGER;
hd: PtrHead;
BEGIN
ASSEMBLER
(*
end:= bl^.hdRov;
usedBeg:= nextHd (bl, end); (* Start of new used area *)
IF end < 0 THEN
freeBeg:= 0; (* End of last used area *)
ELSE
freeBeg:= end + HeadSize + sizeHd (bl, end);
END;
LOOP
IF usedBeg < 0 THEN
IF (SHORT (blkSize (bl)) - freeBeg) >= SHORT (neededLen) THEN EXIT END;
ELSE
IF (usedBeg - freeBeg) >= SHORT (neededLen) THEN EXIT END
END;
IF usedBeg = end THEN RETURN FALSE END;
IF usedBeg < 0 THEN
freeBeg:= 0
ELSE
freeBeg:= usedBeg + HeadSize + sizeHd (bl, usedBeg)
END;
usedBeg:= nextHd (bl, usedBeg)
END;
RETURN TRUE
*)
MOVEM.L D3-D6/A4/A5,-(A7)
MOVE.L -(A3),A5 ; A5: bl
; end:= bl^.hdRov
MOVE.W Block.hdRov(A5),D3 ; D3: end
; usedBeg:= nextHd (bl, end)
MOVE.W Head.hd.n+BlockSize(A5,D3.W),D4 ; D4: usedBeg
; IF end < 0 THEN freeBeg:= 0 ELSE
; freeBeg:= end + HeadSize + sizeHd (bl, end) END;
CLR.W D5 ; D5: freeBeg
TST.W D3
BMI endNeg
MOVE D3,D5
ADDI.W #HeadSize+1,D5
ADD.W Head.size+BlockSize(A5,D3.W),D5
ANDI #$FFFE,D5
endNeg:
MOVE.L -(A3),D6 ; D6: neededLen
MOVEQ #HeadSize+1,D1
MOVE #$FFFE,D2
loop1:
TST D4
BMI ubNeg
ubPos:
MOVE D4,D0
SUB.W D5,D0
CMP.W D6,D0
BCC retTRUE
CMP D3,D4
BEQ retFALSE
MOVE D4,D5
ADD.W D1,D5
ADD.W Head.size+BlockSize(A5,D4.W),D5
AND D2,D5
MOVE.W Head.hd.n+BlockSize(A5,D4.W),D4
BPL ubPos
ubNeg:
MOVE.L Block.size(A5),D0
ANDI.L #$00FFFFFF,D0
SUB.W D5,D0
CMP.W D6,D0
BCC retTRUE
CMP D3,D4
BEQ retFALSE
CLR D5
MOVE.W Head.hd.n+BlockSize(A5,D4.W),D4
BRA loop1
retFALSE:
CLR D0
BRA return
retTRUE:
MOVEQ #1,D0
return:
MOVE.L -(A3),A0 ; ADR (usedBeg)
MOVE D4,(A0)
MOVE.L -(A3),A0 ; ADR (freeBeg)
MOVE D5,(A0)
MOVEM.L (A7)+,D3-D6/A4/A5
MOVE D0,(A3)+
END
END blockOK;
(*$L=*)
PROCEDURE getFree (origLen: LONGINT; VAR neededLen: LONGINT; VAR full: BOOLEAN;
VAR blSize: LONGINT; VAR bl: PtrBlock;
VAR usedBeg, freeBeg: INTEGER): BOOLEAN;
VAR bl0: PtrBlock;
BEGIN (* getFree *)
neededLen:= origLen;
IF ODD (neededLen) THEN INC (neededLen) END;
full:= (neededLen + LONG(HeadSize)) >= MaxBlSize;
IF NOT full THEN
INC (neededLen, HeadSize); (* der Head mu nun auf jeden Fall rein *)
bl0:= Root.blRov;
IF bl0 = NIL THEN bl0:= ADDRESS (Root.blk.next) END;
bl:= bl0;
REPEAT (* alle Blocks nach freiem Platz durchsuchen *)
IF (bl # ADR (Root))
AND NOT blkFull (bl)
AND (bl^.free >= neededLen) THEN
IF blockOK (freeBeg, usedBeg, neededLen, bl) THEN
RETURN TRUE
END
END;
bl:= ADDRESS (bl^.blk.next)
UNTIL bl = bl0;
blSize:= MaxBlSize + LONG (BlockSize)
ELSE
blSize:= neededLen + LONG (BlockFullSize)
END;
RETURN FALSE
END getFree;
PROCEDURE alloc (origLen: LONGINT; level: INTEGER): ADDRESS;
VAR freeBeg, usedBeg: INTEGER;
bl: PtrBlock;
blSize, neededLen: LONGINT;
full: BOOLEAN;
PROCEDURE newBlock (): BOOLEAN;
BEGIN
StorBase.SysAlloc (bl, blSize);
IF bl = NIL THEN RETURN FALSE END;
IF full THEN
linkBlkIn (bl^.blk, Root.blk);
bl^.size:= origLen;
bl^.level:= level;
setBit6 (bl^.size); (* full-Kennung *)
bl^.full:= 0; (* full-Kennung *)
ELSE
WITH bl^ DO
linkBlkIn (blk, Root.blk);
size:= MaxBlSize; (* 'size' enth. Gre des verfgbaren Bereichs *)
free:= size;
hd.n:= rel (bl, ADR (hd));
hd.p:= hd.n;
hdRov:= hd.n
END
END;
Root.blRov := bl;
RETURN TRUE
END newBlock;
PROCEDURE insert (): ADDRESS;
(* Bereich belegen *)
VAR hd: PtrHead;
BEGIN
(* 'bl' zeigt auf Block, der freien Bereich enthlt *)
hd:= abs (bl, freeBeg);
hd^.size:= SHORT (origLen);
hd^.level:= level;
linkHdIn (bl, hd^.hd, usedBeg);
hd^.root:= freeBeg;
DEC (bl^.free, CARDINAL (SHORT (neededLen))); (* origLen + HeadSize *)
bl^.hdRov:= freeBeg;
Root.blRov := bl;
RETURN ADR (hd^.data)
END insert;
VAR lastMax: LONGCARD;
BEGIN (* alloc *)
IF origLen = 0L THEN
RETURN NIL
END;
IF getFree (origLen, neededLen, full, blSize, bl, usedBeg, freeBeg) THEN
RETURN insert ()
END;
IF NOT newBlock () THEN
IF full THEN RETURN NIL END;
(*
* wenn weniger als MaxBlSize bentigt, aber nicht mehr Platz fr
* einen ganzen neuen Verwaltungsblock da ist, dann eben einen
* full-Block mit der bentigten Size anfordern.
*)
lastMax:= MaxBlSize;
MaxBlSize:= origLen; (* full-Block erzwingen *)
IF getFree (origLen, neededLen, full, blSize, bl, usedBeg, freeBeg) THEN
(* mu FALSE liefern *)
END;
MaxBlSize:= lastMax;
IF NOT newBlock () THEN RETURN NIL END
END;
IF full THEN RETURN ADR (bl^.fullData) END;
IF NOT blockOK (freeBeg, usedBeg, neededLen, bl) THEN
ASSEMBLER
TRAP #6
DC.W InternalFault-$C000 ; text follows, caller caused
ACZ 'Storage allocation error'
SYNC
END
END;
RETURN insert ()
END alloc;
PROCEDURE Verify (): CARDINAL;
(*
* Liefert 0, wenn alle Block- und Head-Verkettungen OK sind
*
* VORSICHT: Da auch full-Blocks angelegt werden knnen, die
* kleiner als MaxBlSize sind, keinesfalls full-Blocks
* dahingehend prfen!
*)
(* VAR bl: PtrBlock; hd: PtrHead; freeBeg, usedBeg: INTEGER; l: LONGINT; *)
VAR result: CARDINAL;
(*$R-*)
BEGIN
ASSEMBLER
LEA Root,A0
BRA loop1
err1
BRA.W errEnd
loop1
MOVE.L Block.blk.next(A0),A0
MOVE.L A0,D0
BTST #0,D0 ; ungerade?
BNE err1
(* das geht nicht im Fast-RAM des TT!!!
CMPA.L _membot,A0 ; < membot?
BCS err1
CMPA.L _memtop,A0 ; > memtop?
BCC err1
*)
CMPA.L #Root,A0
BEQ.W exit1 ; ende ? -> OK
BTST #6,Block.size(A0)
BEQ notFull
TST.L Block.size(A0)
BMI err1
MOVE.W Block.level(A0),D0
CMP.W StorLevel,D0
BHI err1
TST.W Block.full(A0)
BNE err1
BRA loop1
notFull
; IF bl^.size > (MaxBlSize + LONG (BlockSize)) THEN RETURN 4 END;
MOVE.L Block.size(A0),D1
(* *** das darf nicht geprft werden, weil MaxBlSize variieren kann! ***
MOVE.L MaxBlSize,D0
ADDI.L #BlockSize,D0
CMP.L D0,D1
BHI err1
*)
; IF bl^.free >= bl^.size THEN RETURN 18 END;
MOVE.L Block.free(A0),D0
CMP.L D1,D0
BCC err1
; IF ODD (bl^.size) THEN RETURN 5 END;
BTST #0,D1
BNE err1
; hd:= abs (bl, bl^.hdRov);
MOVE.W Block.hdRov(A0),D0
BTST #0,D0
BNE err1
LEA BlockSize(A0,D0.W),A2
; IF hd^.root # bl^.hdRov THEN RETURN 6 END;
CMP.W Head.root(A2),D0
BNE err1
; usedBeg:= bl^.hd.n;
MOVE.W Block.hd.n(A0),D1 ; usedBeg
; l:= 0;
CLR.W -(A7) ; l
BRA loop2
err2
ADDQ.L #2,A7
BRA err1
loop2
; IF ODD (usedBeg) THEN RETURN 7 END;
BTST #0,D1
BNE err2
; IF usedBeg < 0 THEN
TST.W D1
BPL notNeg
; IF usedBeg # rel (bl, ADR (bl^.hd)) THEN RETURN 8 END;
CMPI.W #$FFF6,D1
BNE err2
; EXIT
BRA exit2
; END;
notNeg
; hd:= abs (bl, usedBeg);
LEA BlockSize(A0,D1.W),A2
; IF prevHd (bl, nextHd (bl, usedBeg)) # usedBeg THEN RETURN 20 END;
; IF ODD (nextHd (bl, usedBeg)) THEN RETURN 14 END;
MOVE.W Head.hd.n+BlockSize(A0,D1.W),D2
BTST #0,D2
BNE err2
CMP.W Head.hd.p+BlockSize(A0,D2.W),D1
BNE err2
; IF nextHd (bl, prevHd (bl, usedBeg)) # usedBeg THEN RETURN 19 END;
; IF ODD (prevHd (bl, usedBeg)) THEN RETURN 15 END;
MOVE.W Head.hd.p+BlockSize(A0,D1.W),D2
BTST #0,D2
BNE err2
CMP.W Head.hd.n+BlockSize(A0,D2.W),D1
BNE err2
; IF hd^.size < 0 THEN RETURN 9 END;
MOVEQ #0,D2
MOVE.W Head.size(A2),D2
BLE err2 ; hd.size <= 0 ?
; IF LONG (hd^.size) > bl^.size THEN RETURN 10 END;
CMP.L Block.size(A0),D2
BHI err2
; IF hd^.level > StorLevel THEN RETURN 11 END;
MOVE.W Head.level(A2),D0
CMP.W StorLevel,D0
BHI err2
; IF hd^.root # usedBeg THEN RETURN 12 END;
CMP.W Head.root(A2),D1
BNE err2
; INC (l, HeadSize+CARDINAL (hd^.size));
; IF ODD (hd^.size) THEN INC (l) END;
ADDI.W #HeadSize,D2
ADDQ #1,D2
BCLR #0,D2
ADD.W D2,(A7)
BCS err2
(* macht keinen Sinn, weil 'sizeHd' sowieso Sync macht:
; freeBeg:= usedBeg + HeadSize + sizeHd (bl, usedBeg);
; IF ODD (freeBeg) THEN RETURN 13 END;
*)
; usedBeg:= nextHd (bl, usedBeg)
MOVE.W Head.hd.n+BlockSize(A0,D1.W),D1
BRA loop2
exit2
; IF (bl^.size-l) # bl^.free THEN RETURN 17 END
MOVE.L Block.size(A0),D0
MOVEQ #0,D2
MOVE.W (A7)+,D2
SUB.L D2,D0
CMP.L Block.free(A0),D0
BEQ loop1
errEnd
LEA Root,A0
MOVE.L A0,Block.blk.next(A0) ; Liste retten, indem Liste geleert wird
MOVE.L A0,Block.blk.prev(A0)
CLR.L Block.blRov(A0)
MOVEQ #1,D0
BRA ende
exit1
MOVEQ #0,D0
ende
MOVE D0,result(A6)
END;
RETURN result
(*
bl:= ADR (Root);
LOOP
bl:= ADDRESS (bl^.blk.next);
IF bl = ADR (Root) THEN EXIT END;
IF blkFull (bl) THEN
(* Block-Werte prfen *)
IF bl^.size < 0L THEN RETURN 1 END;
IF bl^.level > StorLevel THEN RETURN 2 END;
IF bl^.full # 0 THEN RETURN 3 END;
ELSE
(* Block-Werte prfen *)
(*** das darf nicht geprft werden, weil MaxBlSize variieren kann! ***
IF bl^.size > (MaxBlSize + LONG (BlockSize)) THEN RETURN 4 END;
*)
IF bl^.free >= bl^.size THEN RETURN 18 END;
IF ODD (bl^.size) THEN RETURN 5 END;
hd:= abs (bl, bl^.hdRov);
IF hd^.root # bl^.hdRov THEN RETURN 6 END;
usedBeg:= bl^.hd.n; (* Start of new used area *)
l:= 0;
LOOP
IF ODD (usedBeg) THEN RETURN 7 END;
IF usedBeg < 0 THEN
IF usedBeg # rel (bl, ADR (bl^.hd)) THEN RETURN 8 END;
EXIT
END;
hd:= abs (bl, usedBeg);
(* Head prfen *)
IF nextHd (bl, prevHd (bl, usedBeg)) # usedBeg THEN RETURN 19 END;
IF prevHd (bl, nextHd (bl, usedBeg)) # usedBeg THEN RETURN 20 END;
IF hd^.size < 0 THEN RETURN 9 END;
IF LONG (hd^.size) > bl^.size THEN RETURN 10 END;
IF hd^.level > StorLevel THEN RETURN 11 END;
IF hd^.root # usedBeg THEN RETURN 12 END;
INC (l, HeadSize+CARDINAL (hd^.size));
IF ODD (hd^.size) THEN INC (l) END;
freeBeg:= usedBeg + HeadSize + sizeHd (bl, usedBeg);
IF ODD (freeBeg) THEN RETURN 13 END;
IF ODD (nextHd (bl, usedBeg)) THEN RETURN 14 END;
IF ODD (prevHd (bl, usedBeg)) THEN RETURN 15 END;
IF nextHd (bl, prevHd (bl, usedBeg))
# prevHd (bl, nextHd (bl, usedBeg)) THEN RETURN 16 END;
usedBeg:= nextHd (bl, usedBeg)
END;
IF (bl^.size-l) # bl^.free THEN RETURN 17 END
END;
END;
RETURN 0
*)
END Verify;
(*$R=*)
(*$R-*)
PROCEDURE Inconsistent (): BOOLEAN;
BEGIN
RETURN StorBase.Inconsistent () OR (Verify () # 0)
END Inconsistent;
PROCEDURE ALLOCATE ( VAR addr: ADDRESS; size: LONGCARD );
(*$L-*)
BEGIN
ASSEMBLER
; addr:= alloc (size, StorLevel);
CLR.L D0
MOVE.L -(A3),D1 ; size
BLE error
MOVE.L D1,(A3)+
MOVE StorLevel,(A3)+
JSR alloc
MOVE.L -(A3),D0
error
MOVE.L -(A3),A0 ; addr
MOVE.L D0,(A0)
END;
END ALLOCATE;
(*$L=*)
PROCEDURE SysAlloc ( VAR addr: ADDRESS; size: LONGCARD );
(*$L-*)
BEGIN
ASSEMBLER
; addr:= alloc (size, 0);
CLR.L D0
MOVE.L -(A3),D1 ; size
BLE error
MOVE.L D1,(A3)+
CLR (A3)+
JSR alloc
MOVE.L -(A3),D0
error
MOVE.L -(A3),A0 ; addr
MOVE.L D0,(A0)
END;
END SysAlloc;
(*$L=*)
PROCEDURE DEALLOCATE ( VAR addr: ADDRESS; size: LONGCARD );
BEGIN
IF LONGINT (size) < 0 THEN
size:= MAX (LONGINT)
END;
IF NOT resize (addr, size) THEN
(* versuchen wir's mit StorBase... *)
IF (size # 0) & NOT StorBase.FullStorBaseAccess () THEN
(* nichts freigeben *)
RETURN
END;
StorBase.DEALLOCATE (addr, size)
END;
END DEALLOCATE;
PROCEDURE Available ( size: LONGCARD ): BOOLEAN;
(*
VAR freeBeg, usedBeg: INTEGER;
bl: PtrBlock;
blSize, neededLen: LONGINT;
full: BOOLEAN;
*)
VAR ad: ADDRESS;
BEGIN
(* Alt:
IF getFree (size, neededLen, full, blSize, bl, usedBeg, freeBeg) THEN
RETURN TRUE
ELSE
RETURN StorBase.Available (blSize)
END
*)
(* 29.7.90: *)
ALLOCATE (ad, size);
IF ad = NIL THEN RETURN FALSE END;
DEALLOCATE (ad, 0);
RETURN TRUE
END Available;
PROCEDURE MemSize ( addr: ADDRESS ): LONGCARD;
VAR hd: PtrHead; bl: PtrBlock; full: BOOLEAN;
BEGIN
IF valid (addr,bl,hd,full) THEN
IF full THEN
RETURN blkSize (bl)
ELSE
RETURN LONG (hd^.size)
END
ELSE
IF StorBase.FullStorBaseAccess () THEN
RETURN StorBase.MemSize (addr)
ELSE
RETURN 0
END
END
END MemSize;
PROCEDURE MemAvail (): LONGCARD;
VAR l: LONGINT;
BEGIN
(* Aus Programmierfaulheit suchen wir nicht extra in den Blocks
* nach dem grten Block sondern fragen nur StorBase.
*)
l:= INT (StorBase.MemAvail ()) - LONG (BlockSize+BlockFullSize+2);
IF l < 0 THEN l:= 0 END;
RETURN l
END MemAvail;
PROCEDURE AllAvail (): LONGCARD;
VAR bl: PtrBlock; av: LONGINT;
BEGIN
av:= StorBase.AllAvail ();
bl:= ADR (Root);
LOOP
bl:= ADDRESS (bl^.blk.next);
IF bl = ADR (Root) THEN EXIT END; (* wir haben alle Blocks durch *)
IF NOT blkFull (bl) THEN
av:= av + bl^.free
END;
END;
RETURN av
END AllAvail;
PROCEDURE Keep ( addr: ADDRESS );
VAR hd: PtrHead; bl: PtrBlock; full: BOOLEAN;
BEGIN
IF valid (addr,bl,hd,full) THEN
IF full THEN
bl^.level:= 0
ELSE
hd^.level:= 0
END
ELSE
StorBase.Keep (addr)
END
END Keep;
PROCEDURE Enlarge ( VAR addr: ADDRESS; add: LONGCARD; VAR ok: BOOLEAN );
BEGIN
ok:= FALSE;
IF LONGINT (add) >= 0 THEN
IF NOT resize (addr, -LONGINT (add)) THEN
IF StorBase.FullStorBaseAccess () THEN
StorBase.Enlarge (addr, add, ok)
END
ELSE
ok:= TRUE
END
END
END Enlarge;
PROCEDURE TrailAvail (ad: ADDRESS): LONGCARD;
VAR hd: PtrHead; bl: PtrBlock; full: BOOLEAN;
BEGIN
IF valid (ad,bl,hd,full) THEN
RETURN 0 (* !!! hier fehlt was *)
ELSE
RETURN StorBase.TrailAvail (ad)
END;
END TrailAvail;
PROCEDURE More (id:INTEGER;p:ADDRESS);
(*$L-*)
BEGIN
ASSEMBLER
MOVE.L -(A3),A0
MOVE.W -(A3),D0
CMPI.W #$4EF1,D0
BNE trail
MOVE.L (A0)+,(A3)+
MOVE.L (A0)+,(A3)+
MOVE.L (A0)+,(A3)+
; Enlarge ( VAR addr: ADDRESS; len: LONGCARD; VAR ok: BOOLEAN );
JMP Enlarge
trail
CMPI.W #$4EF2,D0
BNE getRoot
MOVE.L (A0)+,(A3)+
MOVE.L A0,-(A7)
; TrailAvail (ad: ADDRESS): LONGCARD;
JSR TrailAvail
MOVE.L (A7)+,A0
MOVE.L -(A3),(A0)
BRA ende
getRoot
CMPI.W #$4EF3,D0
BNE _verify
MOVE.L #Root,(A0)
BRA ende
_verify
CMPI.W #$4EF4,D0
BNE _resize
MOVE.L #Verify,(A0)
BRA ende
_resize
CMPI.W #$4EF5,D0
BNE ende
MOVE.L #resize,(A0)
ende
END
END More;
(*$L=*)
(* --------------------------------- *)
(* --------------------------------- *)
PROCEDURE terminate;
VAR bl1, bl: PtrBlock; ad: ADDRESS;
VAR usedBeg: INTEGER; hd: PtrHead;
(*$L-*)
BEGIN
ASSEMBLER
; bl:= ADDRESS (Root.blk.next);
MOVE.L Root,A0
; LOOP
loopBeg
; IF bl = ADR (Root) THEN EXIT END; (* wir haben alle Blocks durch *)
CMPA.L #Root,A0
BEQ exitLoop
; bl1:= ADDRESS (bl^.blk.next);
MOVE.L (A0),A2
; IF blkFull (bl) THEN
BTST #6,Block.size(A0)
BEQ notFull
; IF bl^.level = StorLevel THEN
MOVE.W Block.level(A0),D0
CMP.W StorLevel,D0
BNE notLev
; ad:= ADR (bl^.fullData);
; DEALLOCATE (ad, 0)
PEA Block.fullData(A0)
MOVE.L A7,(A3)+
CLR.L (A3)+
MOVE.L A2,-(A7)
JSR DEALLOCATE
MOVE.L (A7)+,A2
ADDQ.L #4,A7
; END
notLev
BRA wasFull
; ELSE
notFull
; usedBeg:= bl^.hd.n; (* Start of new used area *)
MOVE.W Block.hd.n(A0),D0
; WHILE usedBeg >= 0 DO
whileBeg
TST.W D0
BMI whileEnd
; hd:= abs (bl, usedBeg);
; MOVE.L A0,A1
; ADDA.W D0,A1
; ADDA.W #BlockSize,A1
LEA BlockSize(A0,D0.W),A1
; usedBeg:= nextHd (bl, usedBeg);
MOVE.W Head.hd.n+BlockSize(A0,D0.W),D0
; IF hd^.level = StorLevel THEN
MOVE.W Head.level(A1),D1
CMP.W StorLevel,D1
BNE notLev2
; ad:= ADR (hd^.data);
; DEALLOCATE (ad, 0)
PEA Head.data(A1)
MOVE.L A7,(A3)+
CLR.L (A3)+
MOVEM.L D0/A0/A2,-(A7)
JSR DEALLOCATE
MOVEM.L (A7)+,D0/A0/A2
ADDQ.L #4,A7
; END
notLev2
; END
BRA whileBeg
whileEnd
; END;
wasFull
; bl:= bl1
MOVE.L A2,A0
; END;
BRA loopBeg
exitLoop
; DEC (StorLevel) (* wird zu Null, wenn Prg terminiert; somit werden *)
(* bei resid. Prgs dann die Allocs wie SysAlloc be-*)
(* handelt; ein neuer Proze startet wieder mit *)
(* Level 1 *)
SUBQ.W #1,StorLevel
END
END terminate;
(*$L=*)
(*$L-*)
PROCEDURE chgLevel ( doInc: BOOLEAN; child: BOOLEAN; VAR c: INTEGER );
BEGIN
ASSEMBLER
SUBQ.L #4,A3
MOVE.L -(A3),D0
TST D0 ; child
BEQ ende
SWAP D0
TST D0
BNE inc
JMP terminate
inc
ADDQ.W #1,StorLevel
ende
END
END chgLevel;
(*$L=*)
VAR ehdl: EnvlpCarrier;
thdl: TermCarrier;
wsp: MemArea;
BEGIN (* main *)
WITH Root DO
blk.prev:= ADR (Root);
blk.next:= ADR (Root);
blRov:= NIL
END;
StorLevel:= 1;
IF MaxBlSize = 0L THEN
IF Accessory () THEN
MaxBlSize:= 2048;
ELSE
MaxBlSize:= StorBase.MemAvail () DIV 40L;
END
END;
IF MaxBlSize > $7F00L THEN MaxBlSize:= $7F00 END;
IF ODD (MaxBlSize) THEN DEC (MaxBlSize) END;
CatchProcessTerm (thdl,terminate,wsp);
SetEnvelope (ehdl,chgLevel,wsp);
ASSEMBLER
PEA X(PC)
MOVE #38,-(A7)
TRAP #14
ADDQ.L #6,A7
BRA CONT
X MOVE.L $432,_membot
MOVE.L $436,_memtop
RTS
CONT
END
END Storage.